home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 011-020 / amok11 / r.o.m. / m2sources / mymathtrans.mod < prev    next >
Text File  |  1993-11-04  |  11KB  |  448 lines
  1. IMPLEMENTATION MODULE MyMathTrans;
  2. (*
  3.   Created:   29.8.87 by
  4.   Changed:   25.1.88/18.02.88/4.8.88/25.8.88/29.9.88
  5.              Stefan Salewski
  6.              Stolper Weg 3
  7.              2160 Stade   West-Germany
  8.              Tel: 04141/61130
  9.              
  10.   Note: compiled with AMIGA Modula-2 System by AMSoft from 5.5.88
  11.    
  12.   This Module may be freely copied. But please
  13.   leave my name in. Thanks....Stefan  
  14. *)
  15.  
  16.   FROM SYSTEM IMPORT FFP;
  17.   FROM MyMathLibLong IMPORT errorNumber,unit,AngleUnit;
  18.   FROM MathTrans IMPORT Acos,Asin,Atan,Cos,Cosh,Exp,Log,Log10,Pow,
  19.                         Sin,Sinh,Sqrt,Tan,Tanh,Fieee;
  20.   CONST 
  21.     MaxFFP=MAX(FFP);
  22.     TwoPi=6.2831853;
  23.     DegToRad=TwoPi/360.0;
  24.     GonToRad=TwoPi/400.0;
  25.     RadToDeg=360.0/TwoPi;
  26.     RadToGon=400.0/TwoPi;
  27. (****************************************************************************)
  28.   PROCEDURE MyUnit(w:FFP):FFP;
  29.   (* rechnet Winkel in Grad oder Neugrad in Radiant um, wenn unit # rad     *)
  30.   BEGIN
  31.     IF unit=deg THEN
  32.       RETURN w*DegToRad
  33.     ELSIF unit=gon THEN
  34.       RETURN w*GonToRad
  35.     ELSE
  36.       RETURN w
  37.     END
  38.   END MyUnit;
  39. (****************************************************************************)
  40.   PROCEDURE YourUnit(w:FFP):FFP;
  41.   (* Rechnet Resultate von rad in die durch unit bestimmte Einheit um *)
  42.   BEGIN
  43.     IF unit=deg THEN
  44.       RETURN w*RadToDeg
  45.     ELSIF unit=gon THEN
  46.       RETURN w*RadToGon
  47.     ELSE
  48.       RETURN w
  49.     END
  50.   END YourUnit;
  51. (****************************************************************************)
  52.   PROCEDURE NeutraleFunc(x:FFP):FFP;
  53.   BEGIN
  54.     (*errorNumber:=0;*)
  55.     RETURN x
  56.   END NeutraleFunc;
  57. (****************************************************************************)
  58.   PROCEDURE Abs(x:FFP):FFP;
  59.   BEGIN
  60.     (*errorNumber:=0;*)
  61.     RETURN ABS(x)
  62.   END Abs;
  63. (****************************************************************************)
  64.   PROCEDURE Fac(x:FFP):FFP;
  65.   (* Facultaet fuer ganze Zahlen 0 <= n <= 19 *)
  66.     VAR
  67.       j:[0..20];
  68.       intx:INTEGER;
  69.       z:FFP;
  70.       zuklein,zugross,istganz:BOOLEAN;
  71.   BEGIN
  72.     zugross:=x>19.0;
  73.     zuklein:=x<0.0;
  74.     IF (NOT zuklein) AND (NOT zugross) THEN
  75.       intx:=INTEGER(x);
  76.       istganz:=(x=FFP(intx));
  77.       IF istganz THEN
  78.         (*errorNumber:=0;*)
  79.         z:=1.0;
  80.         FOR j:=2 TO intx DO
  81.           z:=z * FFP(j)
  82.         END;
  83.         RETURN z
  84.       ELSE
  85.         errorNumber:=77;
  86.         RETURN 0.0
  87.       END
  88.     ELSIF zugross THEN
  89.       errorNumber:=51;
  90.       RETURN MaxFFP
  91.     ELSE
  92.       errorNumber:=76;
  93.       RETURN 0.0
  94.     END
  95.   END Fac;
  96. (****************************************************************************)
  97.   PROCEDURE Sqr(x:FFP):FFP;
  98.   (* Quadrat *)
  99.   BEGIN
  100.     IF (x<= 1.0E9) THEN
  101.       (*errorNumber:=0;*)
  102.       RETURN x*x;
  103.     ELSE
  104.       errorNumber:=52;
  105.       RETURN MaxFFP
  106.     END
  107.   END Sqr;
  108. (****************************************************************************)
  109.   PROCEDURE Power(x,y:FFP):FFP;
  110.   (*Raise x to the y th power  x^y *)
  111.     CONST
  112.       Epsilon=1.0E-6;
  113.     VAR inty:INTEGER;
  114.       j:CARDINAL;
  115.       z:FFP;
  116.       expNegativ,ok:BOOLEAN;
  117.   BEGIN
  118.     (*errorNumber:=0;*)
  119.     ok:=(ABS(y)<10.0) AND (x<=60.0);
  120.     IF ok THEN
  121.       IF y<0.0 THEN (* runden*)
  122.         inty:=INTEGER(y-0.5)
  123.       ELSE
  124.         inty:=INTEGER(y+0.5)
  125.       END;
  126.     END;
  127.     IF ok AND (ABS(y-FFP(inty))<Epsilon) THEN
  128.       expNegativ:=(inty<0);
  129.       inty:=ABS(inty);
  130.       z:=x;
  131.       x:=1.0;
  132.       FOR j:=1 TO inty DO
  133.         x:=x*z
  134.       END;
  135.       IF expNegativ THEN
  136.         IF x=0.0 THEN 
  137.           errorNumber:=3
  138.         ELSE 
  139.           x:=1.0/x;
  140.         END
  141.       END
  142.     ELSIF y=0.0 THEN
  143.       x:=1.0
  144.     ELSE
  145.       IF x>0.0 THEN
  146.         x:=Exp(y*Log(x));
  147.       ELSE
  148.         x:=0.0;
  149.         errorNumber:=4
  150.       END
  151.     END;
  152.     RETURN x
  153.   END Power;
  154. (****************************************************************************)
  155.   PROCEDURE SIN(x:FFP):FFP;
  156.   BEGIN
  157.     x:=MyUnit(x);
  158.     IF ABS(x) < 1.0E8 THEN
  159.       (*errorNumber:=0;*)
  160.       RETURN Sin(x)
  161.     ELSE
  162.       errorNumber:=18;
  163.       RETURN 0.0
  164.     END;
  165.   END SIN;
  166. (****************************************************************************)
  167.   PROCEDURE COS(x:FFP):FFP;
  168.   BEGIN
  169.     x:=MyUnit(x);
  170.     IF ABS(x) < 1.0E8 THEN
  171.       (*errorNumber:=0;*)
  172.       RETURN Cos(x)
  173.     ELSE
  174.       errorNumber:=18;
  175.       RETURN 0.0
  176.     END
  177.   END COS;
  178. (****************************************************************************)
  179.   PROCEDURE TAN(x:FFP):FFP;
  180.   BEGIN
  181.     x:=MyUnit(x);
  182.     IF ABS(x) < 1.0E8 THEN
  183.       IF Cos(x)=0.0 THEN
  184.         errorNumber:=5;
  185.         RETURN MaxFFP
  186.       ELSE
  187.         (*errorNumber:=0;*)
  188.         RETURN Tan(x)
  189.       END
  190.     ELSE
  191.       errorNumber:=18;
  192.       RETURN 0.0
  193.     END
  194.   END TAN;
  195. (****************************************************************************)
  196.   PROCEDURE Arctan(x:FFP):FFP;
  197.   BEGIN
  198.     RETURN YourUnit(Atan(x))
  199.   END Arctan;
  200. (****************************************************************************)
  201.   PROCEDURE Cot(x:FFP):FFP;
  202.   (* Kotangens  *)
  203.     VAR z:FFP;
  204.   BEGIN
  205.     x:=MyUnit(x);
  206.     IF ABS(x) < 1.0E8 THEN
  207.       z:=Cos(PiHalbe-x);
  208.       IF z=0.0 THEN
  209.         errorNumber:=6;
  210.         RETURN MaxFFP
  211.       ELSE 
  212.         (*errorNumber:=0;*)
  213.         RETURN Sin(PiHalbe-x)/z
  214.       END
  215.     ELSE
  216.       errorNumber:=18;
  217.       RETURN 0.0
  218.     END
  219.   END Cot;
  220. (****************************************************************************)
  221.   PROCEDURE Sec(x:FFP):FFP;
  222.   (*Sekans = 1/cos(x) *)
  223.     VAR y:FFP;
  224.   BEGIN
  225.     x:=MyUnit(x);
  226.     IF ABS(x) < 1.0E8 THEN
  227.       y:=Cos(x);
  228.       IF y=0.0 THEN
  229.         errorNumber:=7;
  230.         RETURN MaxFFP
  231.       ELSE 
  232.         (*errorNumber:=0;*)
  233.         RETURN 1.0/y
  234.       END
  235.     ELSE
  236.       errorNumber:=18;
  237.       RETURN 0.0
  238.     END
  239.   END Sec;
  240. (****************************************************************************)
  241.   PROCEDURE Cosec(x:FFP):FFP;
  242.   (* Kosekans =1/sin(x) *)
  243.     VAR y:FFP;
  244.   BEGIN
  245.     x:=MyUnit(x);
  246.     IF ABS(x) < 1.0E8 THEN
  247.       y:=Sin(x);
  248.       IF y=0.0 THEN
  249.         errorNumber:=8;
  250.         RETURN MaxFFP
  251.       ELSE
  252.         (*errorNumber:=0;*)
  253.         RETURN 1.0/Sin(x)
  254.       END
  255.     ELSE
  256.       errorNumber:=18;
  257.       RETURN 0.0
  258.     END
  259.   END Cosec;
  260. (****************************************************************************)
  261.   PROCEDURE Arcsin(x:FFP):FFP;
  262.   (* ArcusSinus= Umkehrfunktion des Sinus  -1<= x <= +1 *)
  263.   BEGIN
  264.     IF ABS(x)<=1.0 THEN
  265.       (*errorNumber:=0;*)
  266.       RETURN YourUnit(Asin(x))
  267.     ELSE 
  268.       errorNumber:=9;
  269.       RETURN 0.0
  270.     END
  271.   END Arcsin;
  272. (****************************************************************************)
  273.   PROCEDURE Arccos(x:FFP):FFP;
  274.   (* ArcusCosinus = Umkehrfunktion des Cosinus -1 <=x <= +1 *)
  275.   BEGIN
  276.     IF ABS(x)<=1.0 THEN
  277.       (*errorNumber:=0;*)
  278.       RETURN YourUnit(Acos(x))
  279.     ELSE 
  280.       errorNumber:=10;
  281.       RETURN 0.0
  282.     END
  283.   END Arccos;
  284. (****************************************************************************)
  285.   PROCEDURE Arccot(x:FFP):FFP;
  286.   (* ArcusKotangens = Umkehrfunktion des Kotangens *)
  287.   BEGIN
  288.     (*errorNumber:=0;*)
  289.     RETURN YourUnit(PiHalbe-Atan(x))
  290.   END Arccot;
  291. (****************************************************************************)
  292.   PROCEDURE EXP(x:FFP):FFP;
  293.   BEGIN
  294.     IF ABS(x)< 42.0 THEN
  295.       (*errorNumber:=0;*)
  296.       RETURN Exp(x)
  297.     ELSE errorNumber:=11;
  298.       RETURN 0.0
  299.     END
  300.   END EXP;
  301. (****************************************************************************)
  302.   PROCEDURE Ln(x:FFP):FFP;
  303.   (* Natuerlicher Logarithnus*)
  304.   BEGIN
  305.     IF x>0.0  THEN
  306.       (*errorNumber:=0;*)
  307.       RETURN Log(x)
  308.     ELSE
  309.       errorNumber:=12;
  310.       RETURN 0.0
  311.     END
  312.   END Ln;
  313. (*****************************************************************************)
  314.    PROCEDURE LOG(x:FFP):FFP;
  315.    (*Logarithmus zur Basis 10*)
  316.   BEGIN
  317.     IF x>0.0 THEN
  318.       (*errorNumber:=0;*)
  319.       RETURN Log10(x)
  320.     ELSE errorNumber:=13;
  321.       RETURN 0.0
  322.     END
  323.   END LOG;
  324. (****************************************************************************)
  325.   PROCEDURE SINH(x:FFP):FFP;
  326.   (* Sinus Hyperbolicus  bzw. HyperbelSinus *)
  327.   BEGIN
  328.     IF x>42.0 THEN
  329.       errorNumber:=54;
  330.       RETURN MaxFFP
  331.     ELSIF x<-42.0 THEN
  332.       errorNumber:=54;
  333.       RETURN -MaxFFP
  334.     ELSE
  335.       (*errorNumber:=0;*)
  336.       RETURN Sinh(x)
  337.     END
  338.   END SINH;
  339. (****************************************************************************)
  340.   PROCEDURE COSH(x:FFP):FFP;
  341.   (* Cosinus Hyperbolicus bzw. HyperbelCosinus *)
  342.   BEGIN
  343.     IF ABS(x)>42.0 THEN
  344.       errorNumber:=54;
  345.       RETURN MaxFFP
  346.     ELSE
  347.       (*errorNumber:=0;*)
  348.       RETURN Cosh(x)
  349.     END
  350.   END COSH;
  351. (****************************************************************************)
  352.   PROCEDURE TANH(x:FFP):FFP;
  353.   (* Tangens Hyperbolicus bzw. HyperbelTangens *)
  354.   BEGIN
  355.     (*errorNumber:=0;*)
  356.     RETURN Tanh(x)
  357.   END TANH;
  358. (****************************************************************************)
  359.   PROCEDURE Coth(x:FFP):FFP;
  360.   (* Cotanges Hyperbolicus bzw. HyperbelCotangens *)
  361.     VAR y,y1:FFP;
  362.   BEGIN
  363.     IF x#0.0 THEN
  364.       (*errorNumber:=0;*)
  365.       y:=Exp(x);
  366.       y1:=1.0/y;
  367.       RETURN (y+y1)/(y-y1)
  368.     ELSE
  369.       errorNumber:=14;
  370.       RETURN 0.0
  371.     END
  372.   END Coth;
  373. (****************************************************************************)
  374.   PROCEDURE Arsinh(x:FFP):FFP;
  375.   (* AreaSinus = Umkehrfunktion von sinh(x) *)
  376.     VAR y:FFP;
  377.   BEGIN
  378.     (*errorNumber:=0;*)
  379.     y:=Log(x+Sqrt(x*x+1.0));
  380.     RETURN y
  381.   END Arsinh;
  382. (****************************************************************************)
  383.   PROCEDURE Arcosh(x:FFP):FFP;
  384.   (* AreaCosinus = Umkehrfunktion von cosh(x) *)
  385.     VAR y:FFP;
  386.   BEGIN
  387.     IF x>=1.0 THEN
  388.       (*errorNumber:=0;*)
  389.       y:=Log(x+Sqrt(x*x-1.0));
  390.       RETURN y
  391.     ELSE
  392.       errorNumber:=15;
  393.       RETURN 0.0
  394.     END
  395.   END Arcosh;
  396. (****************************************************************************)
  397.   PROCEDURE Artanh(x:FFP):FFP;
  398.   (* AreaTangens = Umkehrfunktion tanh(x) *)
  399.     VAR y:FFP;
  400.   BEGIN
  401.     IF ABS(x)<1.0 THEN
  402.       (*errorNumber:=0;*)
  403.       y:=0.5*Ln((1.0+x)/(1.0-x));
  404.       RETURN y
  405.     ELSE
  406.       errorNumber:=16;
  407.       RETURN 0.0
  408.     END
  409.   END Artanh;
  410. (****************************************************************************)
  411.   PROCEDURE SQRT(x:FFP):FFP;
  412.   BEGIN
  413.     IF x>=0.0 THEN
  414.       (*errorNumber:=0;*)
  415.       RETURN Sqrt(x)
  416.     ELSE
  417.       errorNumber:=17;
  418.       RETURN 0.0
  419.     END
  420.   END SQRT;
  421.   (****************************************************************************)
  422.   PROCEDURE Arcoth(x:FFP):FFP;
  423.   BEGIN
  424.     IF ABS(x)>1.0 THEN
  425.       (*errorNumber:=0;*)
  426.       RETURN 0.5*Log((x+1.0)/(x-1.0))
  427.     ELSE
  428.       errorNumber:=19;
  429.       RETURN 0.0
  430.     END
  431.   END Arcoth;
  432. (****************************************************************************)
  433.   PROCEDURE Int(x:FFP):FFP;
  434.   BEGIN
  435.     IF ABS(x)<2147483648.0 THEN
  436.       (*errorNumber:=0;*)
  437.       RETURN FFP(LONGINT(x))
  438.     ELSE
  439.       errorNumber:=20;
  440.       RETURN 0.0
  441.     END
  442.   END Int;
  443. BEGIN
  444.   unit:=rad;
  445.   errorNumber:=0
  446. END MyMathTrans.mod
  447.  
  448.